--module DictParser where

import qualified Data.ByteString.UTF8 as UB
import qualified Data.ByteString.Char8 as CB
import qualified System.IO.UTF8 as UIO
import System.IO
import Data.Char
import System.Console.GetOpt
import Data.Maybe
import System.Environment(getArgs)
import Control.Monad
import Data.List
import System.Exit
                             
                             
data Flag = Verbose  
          | Version 
          | DictFile FilePath
          | Output String
          | LibDir String
          | PrintHelp
          deriving (Show, Eq)
                   
options :: [OptDescr Flag]
options =
  [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"
  , Option ['V','?'] ["version"] (NoArg Version)       "show version number"
  , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"
  , Option ['d']     ["dict"]    (ReqArg DictFile "FILE")  "input FILE"
  , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"
  , Option ['h']     ["help"]    (NoArg PrintHelp)     "print this help"
  ]
    
outp :: Maybe String -> Flag
outp = Output . fromMaybe "stdout"
    
helpInfo :: String
helpInfo = usageInfo "Usage: dp [OPTION...] files..." options

version :: String
version = "dp version 0.0000000000000001"

compileOpts :: [String] -> IO ([Flag], [String])
compileOpts argv = 
  case getOpt Permute options argv of
    (o,n,[]  ) -> return (o,n)
    (_,_,errs) -> ioError (userError (concat errs ++ helpInfo))
    
handleOpts (flags, others) = do
--  putStrLn $ "flags: " ++ show flags
--  putStrLn $ "others: " ++ show others
  when (PrintHelp `elem` flags) $ putStrLn helpInfo >> exitSuccess
  when (Version `elem` flags) $ putStrLn version >> exitSuccess
  let mDict = find (\e -> case e of { DictFile _ -> True; otherwise -> False }) flags
  when (isNothing mDict) $ error "A dictionary file is required, check help(-h)."
  let DictFile dict = fromJust mDict
  return dict
  

newtype Tone = Tone { tone2Int :: Int } deriving (Eq,Ord)

toneInts = [1,2,3,4,5]
tones = map (\i -> Tone{tone2Int=i}) toneInts

instance Show Tone where
  show Tone{tone2Int=i} = 
    case i of
      0 -> "no-tone"
      1 -> "1st-tone"
      2 -> "2nd-tone"
      3 -> "3rd-tone"
      4 -> "4th-tone"
      5 -> "light-tone"
      otherwise -> "invalid-tone"
  
int2Tone :: Int -> Tone
int2Tone i =
  if i >= 1 && i <= 5
  then Tone{tone2Int = i}
  else Tone{tone2Int = 0}

data Pinyin = Pinyin
              { onset :: Onset
              , rime :: Rime
              , tone :: Tone
              }

mkPinyinList :: UB.ByteString -> [Pinyin]
mkPinyinList bs =
  if CB.null bs
  then []
  else let (py, bs') = UB.break isSpace $ snd $ UB.span isSpace bs
       in if CB.null py 
          then mkPinyinList bs'
          else mkPinyin py : mkPinyinList bs'
       
instance Show Pinyin where
  show Pinyin{onset=os,rime=rm,tone=t} = show os ++ "-" ++ show rm ++ "-" ++ show (tone2Int t)
  
newtype AdjustedPinyin = AdjustedPinyin {apy2s :: String} deriving (Eq)
instance Show AdjustedPinyin where
  show AdjustedPinyin{apy2s=s} = s
  
instance Ord AdjustedPinyin where
  ap1 <= ap2 = map toLower (apy2s ap1) <= map toLower (apy2s ap2)  

newtype Onset = Onset { os2s :: String }
instance Show Onset where
  show Onset{os2s=s} = s
  
onsets = map (\s -> Onset{os2s=s}) onsetStrs
onsetStrs = ["b","p","m","f","d","t","n","l","g","k","h","j","q","w","x","y","zh","ch","sh","r","z","c","s"]

mkOnset :: String -> Maybe Onset
mkOnset s = if s `elem` onsetStrs
            then Just (Onset{os2s = s})
            else Nothing

newtype Rime = Rime {rm2s :: String}
instance Show Rime where
  show Rime{rm2s=s} = s
  
rimes = map (\s -> Rime{rm2s=s}) rimeStrs
rimeStrs = reverse $ sort ["a","ai","an","ang","ao","e","ei","en","eng","er","i","ia","ian","iang","iao","ie","in","ing","iong","iu","o","ong","ou","u","ua","uan","uang","ue","uai","ui","un","uo","u:","u:e"]
s2rm s = Rime {rm2s=s}

vowelChrs :: [Char]
vowelChrs = "aeiou"

rime2arime :: Rime -> Tone -> String
rime2arime rm t =
  case s of
    [] -> if ti == 4 then "h" else "" {-BAD-}
    otherwise -> mod ti 
  where
    s = rm2s rm
    ti = tone2Int t
    mod ti
      | ti == 1 || ti == 5 = case s of
        "ao" -> "au"
        "iao" -> "iau"
        "er" -> "el"
        "u:e" -> "ue"
        "u:" -> "u:"
        otherwise -> s
      | ti == 2 = case s of
        "ao" -> "av"
        "iao" -> "iav"
        "ou" -> "ov"
        "er" -> "erl"
        "u:e" -> "ve"
        "u:" -> "u:r"
        'i':s' -> case s' of
          [] -> "xi"
          otherwise -> 'x':s' 
        'u':s' -> 'v':s'
        otherwise -> let (b,a) = span (`elem` vowelChrs) s in b++"r"++a
      | ti == 3 = case s of
        "ao" -> "ao"
        "iao" -> "iao" -- or "eau"
        "ai" -> "ae"
        "er" -> "eel"
        "u:e" -> "oe"
        "u:" -> "eu:"
        "ie" -> "iee" -- iie is harder to recognize
        'i':s'@(x:s'') | x `elem` "aou" -> 'e':s'
        'u':s'@(x:s'') | x `elem` "aei" -> 'o':s'
        otherwise -> let (x:xs) = s in if x `elem` vowelChrs then x:s else s {-BAD-}
      | ti == 4 = case s of
        "ao" -> "aw"
        "iao" -> "iaw" 
        "ou" -> "ow"
        "er" -> "ell"
        "u:e" -> "we"
        "u:" -> "u:h"
        'u':s' -> case s' of
          [] -> "uh"
          otherwise -> 'w':s'
        'i':s' -> case s' of
          [] -> "ih"
          otherwise -> 'y':s'
        otherwise ->
          let len = length s
          in if len > 1
             then let (b,[a]) = splitAt (len-1) s
                  in case a of
                    'i' -> b ++ "y"
                    'u' -> b ++ "w"
                    'g' -> b ++ "q"
                    'n' -> b ++ "nn"
                    otherwise -> s ++ "h"
             else s ++ "h"
      | otherwise = s {-BAD-}


preElemI :: [String] -> String -> (String, String)
preElemI [] src = ("", src)
preElemI (x:xs) src =
  case stripPrefixSI x src of
    Nothing -> preElemI xs src
    Just h -> h
    
stripPrefixSI :: String -> String -> Maybe (String,String)
stripPrefixSI [] ys = Just ("", ys)
stripPrefixSI (x:xs) ys =
  case ys of
    [] -> Nothing
    y:ys' -> if toLower x == toLower y
             then case stripPrefixSI xs ys' of
                       Nothing -> Nothing
                       Just (b,a) -> Just (y:b, a)
             else Nothing

mkPinyin :: UB.ByteString -> Pinyin
mkPinyin = mkPinyin' . UB.toString

mkPinyin' :: String -> Pinyin
mkPinyin' "r5" = Pinyin{onset=Onset{os2s=""}, rime=s2rm "er", tone=Tone{tone2Int=5}}
mkPinyin' "m2" = Pinyin{onset=Onset{os2s="m"}, rime=s2rm "", tone=Tone{tone2Int=2}}
mkPinyin' "m4" = Pinyin{onset=Onset{os2s="m"}, rime=s2rm "", tone=Tone{tone2Int=4}}
mkPinyin' s =
  let (os,s') = onsetStrs `preElemI` s
      (rm, s'') = rimeStrs `preElemI` s'
  in if rm /= "" && (s'' `elem` map show toneInts)
     then Pinyin {onset=Onset{os2s=os}, rime=s2rm rm, tone=Tone{tone2Int=read s''}}
     else Pinyin {onset=Onset{os2s=s}, rime=s2rm "", tone=Tone{tone2Int=0}}
                
pys2apy :: [Pinyin] -> AdjustedPinyin
pys2apy [] = AdjustedPinyin {apy2s = ""}
pys2apy (Pinyin{onset=os,rime=rm,tone=t}:pys) =
  let s = apy2s (pys2apy pys)
      ar = rime2arime rm t
      ar' = if os2s os == "r" && 'r' `elem` ar then rm2s rm else ar
  in case s of
       x:_ | ar /= [] && [last ar,x]`elem`(["nq","ng"]++rimeStrs) ->
         AdjustedPinyin { apy2s = os2s os ++ ar' ++ ('\'':s) }
       otherwise -> AdjustedPinyin { apy2s = os2s os ++ ar' ++ s }
       
newtype Chinese = Chinese{ c2s :: UB.ByteString } deriving (Eq,Ord)

instance Show Chinese where
  show Chinese{c2s=s} = UB.toString s

data DictEntry = DictEntry 
                 { scLit :: Chinese
                 , tcLit :: Chinese
                 , pyLit :: [Pinyin]
                 , expl :: UB.ByteString
                 }
                 deriving (Show)
                 
type Dict = [DictEntry]

readC :: UB.ByteString -> (Maybe UB.ByteString, UB.ByteString)
readC line = 
  let (sc, line') = UB.break isSpace $ snd $ UB.span isSpace line
  in if CB.null sc 
     then (Nothing, line) 
     else (Just sc, line')
          
readPY :: UB.ByteString -> (Maybe UB.ByteString, UB.ByteString)
readPY line = 
  let line' = snd $ UB.span isSpace line
  in if CB.null line' || CB.head line' /= '['
     then (Nothing, line)
     else let (py, line'') = UB.span (/=  ']') (CB.tail line')
          in if CB.null py || CB.null line''
             then (Nothing, line)
             else (Just py, CB.tail line'')
                  
readE :: UB.ByteString -> (Maybe UB.ByteString, UB.ByteString)
readE line = (Just $ snd $ UB.span isSpace line, UB.fromString "")
          
runPasses :: [UB.ByteString -> (Maybe UB.ByteString, UB.ByteString)] -> UB.ByteString -> Maybe [UB.ByteString]
runPasses [] line =
  if CB.null line
  then Just []
  else Nothing
runPasses (p:ps) line =
  case p line of
    (Nothing, _) -> Nothing
    (Just e, line') ->
      case runPasses ps line' of
        Nothing -> Nothing
        Just es -> Just (e:es)

parseDict :: [UB.ByteString] -> [DictEntry]
parseDict [] = []
parseDict (line:lines) =
  case runPasses [readC, readC, readPY, readE] line of
    Nothing -> parseDict lines
    Just [tc,sc,py,e] -> DictEntry {scLit=Chinese{c2s=sc}, tcLit=Chinese{c2s=tc}, pyLit=mkPinyinList py, expl=e} : parseDict lines
      

listApySC dict =
  let sdict = sort $ map (\DictEntry{scLit=sc,tcLit=tc,pyLit=pys,expl=e} -> (pys2apy pys, UB.toString $ c2s sc)) dict
      gdict = scanl1 (\(lapy,lsc) new@(apy,sc) ->
                       if lapy == apy
                       then (apy, '@':sc)
                       else new) sdict
  in forM_ gdict (\(apy,sc) -> UIO.putStrLn $ show apy ++ " " ++ sc)
     
percent :: Int -> Int -> Float
percent x y = fromIntegral x * 100 / fromIntegral y 
     
statTones dict =
  let cntAndTones = reverse $ sort $ map (\ts@(t:_) -> let len=length ts in (len, len `percent` cntAll, t)) $ group $ sort $ map (\de -> map (\py -> show (onset py) ++ show (tone2Int (tone py))) (pyLit de)) dict
      cntAll = length dict
  in do
    mapM_ UIO.print cntAndTones 
    
listChrs dict =
  let sdict = sort $ map (\de -> (pys2apy (pyLit de), tcLit de)) $ filter (\de -> UB.length (c2s $ tcLit de) == 1) dict
  in forM_ sdict (\(apy,tc) -> UIO.putStrLn $ show apy ++ " " ++ (UB.toString $ c2s tc))
    

main :: IO ()
main = do
  dictPath <- handleOpts =<< compileOpts =<< getArgs
  dh <- openFile dictPath ReadMode
  allIn <- CB.hGetContents dh
  let allLines = UB.lines allIn
      dict = parseDict allLines
  listApySC dict
  hClose dh
